home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
netmail
/
rnr214.zip
/
LINEDRAW.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-02-02
|
5KB
|
263 lines
unit linedraw;
{
Russell_Schulz@locutus.ofB.ORG (960202)
Copyright 1996 Russell Schulz
this code is not in the Public Domain
permission is granted to use these routines in any application regardless
of commercial status as long as the author of these routines assumes no
liability for any damages whatsoever for any reason. have fun.
}
interface
uses dos,crt;
const
maxsavedbytes=4096;
singletlchar=#218;
singletrchar=#191;
singleblchar=#192;
singlebrchar=#217;
singlehlinechar=#196;
singlevlinechar=#179;
doubletlchar=#201;
doubletrchar=#187;
doubleblchar=#200;
doublebrchar=#188;
doublehlinechar=#205;
doublevlinechar=#186;
type
savedbytes=
record
buffer: array[1..maxsavedbytes] of char;
count: integer;
leftx: integer;
topy: integer;
rightx: integer;
bottomy: integer;
end;
procedure writexys(anx,any: integer; astr: string);
procedure singleline(leftx,topy,rightx,bottomy: integer);
procedure singlebox(leftx,topy,rightx,bottomy: integer);
procedure singleboxwh(leftx,topy,width,height: integer);
procedure doubleline(leftx,topy,rightx,bottomy: integer);
procedure doublebox(leftx,topy,rightx,bottomy: integer);
procedure doubleboxwh(leftx,topy,width,height: integer);
procedure emptybox(leftx,topy,rightx,bottomy: integer);
procedure emptyboxwh(leftx,topy,width,height: integer);
procedure savearea(leftx,topy,rightx,bottomy: integer;
var saved: savedbytes);
procedure saveareawh(leftx,topy,width,height: integer;
var saved: savedbytes);
{for restore, saved is var only for efficiency}
procedure restorearea(var saved: savedbytes);
procedure staticpopup(anx,any: integer; astr: string);
procedure removepopup;
implementation
var
staticpopupsavedbytes: savedbytes;
procedure writexys;
begin
gotoxy(anx,any);
write(astr);
end;
procedure singleline;
var
onex,oney: integer;
begin
if leftx=rightx then
for oney := topy to bottomy do
writexys(leftx,oney,singlevlinechar)
else
for onex := leftx to rightx do
writexys(onex,topy,singlehlinechar)
end;
procedure singlebox;
var
x,y: integer;
begin
singleline(leftx,topy,rightx,topy);
singleline(leftx,bottomy,rightx,bottomy);
singleline(leftx,topy,leftx,bottomy);
singleline(rightx,topy,rightx,bottomy);
writexys(leftx,topy,singletlchar);
writexys(rightx,topy,singletrchar);
writexys(leftx,bottomy,singleblchar);
writexys(rightx,bottomy,singlebrchar);
end;
procedure singleboxwh;
begin
singlebox(leftx,topy,leftx+width-1,topy+height-1);
end;
procedure doubleline;
var
onex,oney: integer;
begin
if leftx=rightx then
for oney := topy to bottomy do
writexys(leftx,oney,doublevlinechar)
else
for onex := leftx to rightx do
writexys(onex,topy,doublehlinechar)
end;
procedure doublebox;
var
x,y: integer;
begin
doubleline(leftx,topy,rightx,topy);
doubleline(leftx,bottomy,rightx,bottomy);
doubleline(leftx,topy,leftx,bottomy);
doubleline(rightx,topy,rightx,bottomy);
writexys(leftx,topy,doubletlchar);
writexys(rightx,topy,doubletrchar);
writexys(leftx,bottomy,doubleblchar);
writexys(rightx,bottomy,doublebrchar);
end;
procedure doubleboxwh;
begin
doublebox(leftx,topy,leftx+width-1,topy+height-1);
end;
procedure emptybox;
var
anx, any: integer;
begin
for any := topy+1 to bottomy-1 do
begin
gotoxy(leftx+1,any);
for anx := leftx+1 to rightx-1 do
write(' ');
end;
end;
procedure emptyboxwh;
begin
emptybox(leftx,topy,leftx+width-1,topy+height-1);
end;
procedure savearea;
var
anx,any: integer;
regs: registers;
begin
saved.leftx := leftx;
saved.topy := topy;
saved.rightx := rightx;
saved.bottomy := bottomy;
saved.count := 0;
for anx := leftx to rightx do
for any := topy to bottomy do
if saved.count<maxsavedbytes-1 then
begin
gotoxy(anx,any);
{read character+attribute from screen}
regs.ah := 8;
regs.bh := 0;
intr($10,regs);
{first character, then attribute}
inc(saved.count);
saved.buffer[saved.count] := chr(regs.al);
inc(saved.count);
saved.buffer[saved.count] := chr(regs.ah);
end;
end;
procedure saveareawh;
begin
savearea(leftx,topy,leftx+width-1,topy+height-1,saved);
end;
procedure restorearea;
var
anx,any: integer;
currbyte: integer;
regs: registers;
begin
currbyte := 0;
for anx := saved.leftx to saved.rightx do
for any := saved.topy to saved.bottomy do
if currbyte<saved.count then
begin
gotoxy(anx,any);
{first character, then attribute}
inc(currbyte);
regs.al := ord(saved.buffer[currbyte]);
inc(currbyte);
regs.bl := ord(saved.buffer[currbyte]);
{write character+attribute to screen}
regs.ah := 9;
regs.bh := 0;
regs.cx := 1;
intr($10,regs);
end;
end;
procedure staticpopup;
begin
saveareawh(anx,any,length(astr)+2,3,staticpopupsavedbytes);
singleboxwh(anx,any,length(astr)+2,3);
writexys(anx+1,any+1,astr);
end;
procedure removepopup;
begin
restorearea(staticpopupsavedbytes);
end;
end.